[PATCH] <short summary of the patch>

TODO: Put a short summary on the line above and replace this paragraph
with a longer explanation of this change. Complete the meta-information
with other relevant fields (see below for details). To make it easier, the
information below has been extracted from the changelog. Adjust it or drop
it.

Gbp-Pq: Name Version_2_7_2pre38

diff --git a/Makefile.am b/Makefile.am
index 44720f396274178e1be949bf75d1786827cf3b98..dfa1ce07557e24a8c71ae090122526a5afa00960 100644 (file)
--- a/Makefile.am
+++ b/Makefile.am
@@ -467,7 +467,7 @@ ansi_gcl/%.o: ansi_gcl0/%.o | unixport/ansi_gcl
        cp $(patsubst %.o,%.*,$<) $(@D)
 
 
-%.go: %.o mod_gcl/recompile #FIXME parallel
+%.go: %.o unixport/saved_ansi_gcl #FIXME parallel
        $(CC) $(AM_CPPFLAGS) -I $(<D) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \
              -fno-omit-frame-pointer -pg -c $*.c -o $@
        cat $*.data >>$@

diff --git a/Makefile.in b/Makefile.in
index 0c0f13e4b6f4f1643575a4b1c80c983c2a9c7959..80912299afa7b4df7072236a899b3b563274f99c 100644 (file)
--- a/Makefile.in
+++ b/Makefile.in
@@ -4798,7 +4798,7 @@ ansi_gcl0/%.o: clcs/%.lisp | unixport/ansi_gcl0
 ansi_gcl/%.o: ansi_gcl0/%.o | unixport/ansi_gcl
        cp $(patsubst %.o,%.*,$<) $(@D)
 
-%.go: %.o mod_gcl/recompile #FIXME parallel
+%.go: %.o unixport/saved_ansi_gcl #FIXME parallel
        $(CC) $(AM_CPPFLAGS) -I $(<D) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \
              -fno-omit-frame-pointer -pg -c $*.c -o $@
        cat $*.data >>$@

diff --git a/cmpnew/gcl_cmpif.lsp b/cmpnew/gcl_cmpif.lsp
index cf76819c6bccf8ed0e8f8aad771bedd9c3c5007a..623a273d16dcf8a8537b195c75a543de7456c5f3 100644 (file)
--- a/cmpnew/gcl_cmpif.lsp
+++ b/cmpnew/gcl_cmpif.lsp
@@ -79,11 +79,32 @@
 
 (defun real-bnds (t1) (num-type-bounds t1))
 
-(defun two-tp-inf (fn t2 &aux (t2 (real-bnds (type-and #treal t2))))
+(defun =-bnds (tp &aux (ctpn (si::tp-type (tp-and tp #t(complex* real (not (real 0 0)))))))
+  (list (real-bnds (real-imag-tp ctpn t)) (real-bnds (real-imag-tp ctpn nil))
+       (real-bnds (tp-or (tp-and tp #treal)
+                         (real-imag-tp (si::tp-type (tp-and tp #t(complex* real (real 0 0)))) t)))))
+
+(defun =-tp (tp &aux (l (=-bnds tp)))
+  (flet ((f (x) (when x (cons 'real x))))
+    (tp-or (cmp-norm-tp `(complex* ,(f (car l)) ,(f (cadr l))))
+          (tp-or (cmp-norm-tp (f (caddr l)))
+                 (cmp-norm-tp `(complex* ,(f (caddr l)) (real 0 0)))))))
+
+(defun atomic=-tp (tp &aux (l (=-bnds tp)))
+  (flet ((f (x) (when (and (numberp (car x)) (numberp (cadr x)) (= (car x) (cadr x))) (car x))))
+    (cond ((caddr l)
+          (unless (or (car l) (cadr l))
+            (let ((r (f (caddr l))))
+              (when r
+                (cmp-norm-tp `(or (real ,r ,r) (complex* (real ,r ,r) (real 0 0))))))))
+         ((let ((cr (f (car l)))(ci (f (cadr l))))
+            (when (and cr ci)
+              (cmp-norm-tp `(complex* (real ,cr ,cr) (real ,ci ,ci)))))))))
+
+(defun two-tp-inf (fn t2o &aux (t2o (type-and t2o #tnumber))(t2 (real-bnds (tp-and #treal t2o))))
   (case fn
-       (= (cmp-norm-tp `(real ,(or (car t2) '*) ,(or (cadr t2) '*))))
-       (/= (if (when (numberp (car t2)) (eql (car t2) (cadr t2)))
-               (cmp-norm-tp `(and number (not (real ,@t2)))) #treal))
+       (= (=-tp t2o))
+       (/= (tp-and #tnumber (tp-not (atomic=-tp t2o))))
        (>  (cmp-norm-tp `(real ,(cond ((numberp (car t2)) (list (car t2))) ((car t2)) ('*)))))
        (>= (cmp-norm-tp `(real ,(or (car t2) '*))))
        (<  (cmp-norm-tp `(real * ,(cond ((numberp (cadr t2)) (list (cadr t2))) ((cadr t2)) ('*)))))

diff --git a/cmpnew/gcl_cmpmulti.lsp b/cmpnew/gcl_cmpmulti.lsp
index 82cf9fff28fc2ec84e561190931f10b69f74c9d3..b473ef43e0d2f4b761cdabc1bc2f67f37dfec948 100644 (file)
--- a/cmpnew/gcl_cmpmulti.lsp
+++ b/cmpnew/gcl_cmpmulti.lsp
@@ -272,9 +272,11 @@
         (tp (if (eq tp '*) (make-list (length vars) :initial-element t) (cdr tp))))
     (do ((v vars (cdr v)) (t1 tp (cdr t1)))
        ((not v))
-       (set-var-init-type (car v) (if t1 (car t1) #tnull))))
-
-  (dolist (v vars) (push-var v init-form))
+      (let* ((ntp (if t1 (car t1) #tnull))
+            (ni (copy-info (cadr init-form))))
+       (setf (info-type ni) ntp)
+       (set-var-init-type (car v) ntp)
+       (push-var (car v) (list* (car init-form) ni (cddr init-form))))))
 
   (check-vdecl vnames ts is)
 

diff --git a/cmpnew/gcl_cmpopt.lsp b/cmpnew/gcl_cmpopt.lsp
index 533800c58dd3416e14ca03b0296eeaf7874323c6..837f86ab87b3891aa0fc2b17f63e314d6839b042 100644 (file)
--- a/cmpnew/gcl_cmpopt.lsp
+++ b/cmpnew/gcl_cmpopt.lsp
@@ -296,34 +296,43 @@
 (push '((t t) t #.(flags ans) "number_divide(#0,#1)") (get 'si::number-divide 'inline-always))
 (push '((cnum cnum) cnum #.(flags) "(#0)/(#1)") (get 'si::number-divide 'inline-always))
 
-;;/=
- (push '((t t) boolean #.(flags rfa)"immnum_ne(#0,#1)")
-   (get '/= 'inline-always))
-(push '((cnum cnum) boolean #.(flags rfa)"(#0)!=(#1)") (get '/= 'inline-always))
+(deftype creals nil `(or float (and fixnum (signed-byte #.(1+ +sfbits+)))))
+(deftype creall nil `(or long-float (and fixnum (signed-byte #.(1+ +lfbits+)))))
+(deftype cnums nil `(or creals fcomplex dcomplex))
+(deftype cnuml nil `(or creall dcomplex))
+
+(labels ((cop (op) (or (cdr (assoc op '((= . ==)(/= . !=)))) op))
+        (minl (args s) `(,args boolean #.(flags rfa) ,s))
+        (str (s) (string-downcase (remove #\- (string s))))
+        (minla (op) (ms "((#0)" (cop op) "(#1))"))
+        (minlb (op args &aux (p (position 'fixnum args))(s (nth (- 1 p) args)))
+          (ms "(FIX" (if (member s '(short-float fcomplex)) "S" "L") "FSP(#" p ") ? "
+              "number_compare(make_" (if (zerop p) "fixnum" (str s)) "(#0),make_"
+              (if (zerop p) (str s) "fixnum") "(#1))" (cop op) "0 : " (minla op) ")"))
+        (minls (op args) (minl args (minlb op args)))
+        (minlf (op args) (minl args (minla op)))
+        (minlt (s iap)
+          (mapc (lambda (x) (when x (push x (get s 'inline-always))))
+                (list
+                 (minl '(t t) (ms "immnum_" iap "(#0,#1)"))
+                 (unless (eq (cop s) s) (minls s '(fixnum fcomplex)))
+                 (minls s '(fixnum short-float))
+                 (unless (eq (cop s) s) (minls s '(fcomplex fixnum)))
+                 (minls s '(short-float fixnum))
+                 (unless (eq (cop s) s) (minls s '(fixnum dcomplex)))
+                 (minls s '(fixnum long-float))
+                 (unless (eq (cop s) s)  (minls s '(dcomplex fixnum)))
+                 (minls s '(long-float fixnum))
+                 (minlf s '(fixnum fixnum))
+                 (minlf s (if (eq (cop s) s) '(creall creall) '(cnuml cnuml)))
+                 (minlf s (if (eq (cop s) s) '(creals creals) '(cnums cnums)))))))
+
+  (mapc (lambda (x) (apply #'minlt x)) '((< "lt")(<= "le")(> "gt")(>= "ge")(= "eq")(/= "ne"))))
 
-;;<
- (push '((t t) boolean #.(flags rfa)"immnum_lt(#0,#1)") (get '< 'inline-always))
-(push '((creal creal) boolean #.(flags rfa)"(#0)<(#1)") (get '< 'inline-always))
 
 ;;compiler::objlt
  (push '((t t) boolean #.(flags rfa)"((object)(#0))<((object)(#1))") (get 'si::objlt 'inline-always))
 
-;;<=
- (push '((t t) boolean #.(flags rfa)"immnum_le(#0,#1)") (get '<= 'inline-always))
-(push '((creal creal) boolean #.(flags rfa)"(#0)<=(#1)") (get '<= 'inline-always))
-
-;;=
- (push '((t t) boolean #.(flags rfa)"immnum_eq(#0,#1)") (get '= 'inline-always))
-(push '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get '= 'inline-always))
-
-;;>
- (push '((t t) boolean #.(flags rfa)"immnum_gt(#0,#1)") (get '> 'inline-always))
-(push '((creal creal) boolean #.(flags rfa)"(#0)>(#1)") (get '> 'inline-always))
-
-;;>=
- (push '((t t) boolean #.(flags rfa)"immnum_ge(#0,#1)") (get '>= 'inline-always))
-(push '((creal creal) boolean #.(flags rfa)"(#0)>=(#1)") (get '>= 'inline-always))
-
 ;;APPEND
 ;;  (push '((t t) t #.(flags ans)"append(#0,#1)")
 ;;    (get 'append 'inline-always))

diff --git a/git.tag b/git.tag
index eb7f1dc4a74dee248d95f13cbc6a2b9551bc178d..7df294342f407dbd15b32dd70f5ca624b8d1f105 100644 (file)
--- a/git.tag
+++ b/git.tag
@@ -1 +1 @@
-"Version_2_7_2pre37"
+"Version_2_7_2pre38"

diff --git a/h/compdefs.h b/h/compdefs.h
index db7aeb62baababcb31e25ae094236a97e8800c29..26827a81a849e4c9be3b5e104a55793e03ef8e0c 100644 (file)
--- a/h/compdefs.h
+++ b/h/compdefs.h
@@ -95,3 +95,5 @@ NO_RETURN
 CHAR_SIZE
 MAX_ARGS
 bool
+FIXSFSP(x)
+FIXLFSP(x)

diff --git a/h/elf32_ppc_reloc.h b/h/elf32_ppc_reloc.h
index 7882329a44ed78829e57caaef4a4c9349fa1d0a6..0633943409908018826e082dc026d964990f8230 100644 (file)
--- a/h/elf32_ppc_reloc.h
+++ b/h/elf32_ppc_reloc.h
@@ -2,7 +2,7 @@
       s+=a;
       if (ovchks(s,~MASK(26)))
         store_val(where,MASK(26),s|0x3);
-      else  if (ovchks(s-p,~MASK(26)))
+      else if (ovchks(s-p,~MASK(26)))
         store_val(where,MASK(26),(s-p)|0x1); 
       else massert(!"REL24 overflow");
         break;

diff --git a/h/notcomp.h b/h/notcomp.h
index 35646f408362ba5eb64d6aa5087f674c2aa7b699..589ecdc65fd5a52beef1c94d0a06e3f68ea2263e 100755 (executable)
--- a/h/notcomp.h
+++ b/h/notcomp.h
@@ -362,3 +362,15 @@ EXTER gmp_randfnptr_t Mersenne_Twister_Generator_Noseed;
   type_of(strm_)==t_stream ? read_object_non_recursive(strm_) : fSread_fasd_top(strm_)
 
 #define NO_TRUENAME (raw_image || no_truename)
+
+
+#define UFIX(x) ({fixnum _x=(x);_x^(_x>>(sizeof(fixnum)*8-1));})
+
+#define SFBITS 24
+#define LFBITS 53
+
+#define FMSK(a_) ((~(0ULL))&(~((1ULL<<(a_))-1)))
+
+#define FIXSFSP(x) (UFIX(x)&FMSK(SFBITS))
+#define FIXLFSP(x) (UFIX(x)&FMSK(LFBITS))
+

diff --git a/lsp/gcl_deftype.lsp b/lsp/gcl_deftype.lsp
index 0e1ad466506c28c766d61a0b52dcb1060460b286..e762157101cbeb423fa3872ed652aff514542532 100644 (file)
--- a/lsp/gcl_deftype.lsp
+++ b/lsp/gcl_deftype.lsp
@@ -279,7 +279,7 @@
     (ratio
      (let ((z (rational nx)))
        (if (eql z nx) (if (integerp x) (list x) x)
-          (if a z (list z)))))
+          (if (unless (integerp z) a) z (list z)))))
     (short-float (f 0.0s0))
     (long-float (f 0.0)))))
 

diff --git a/o/num_comp.c b/o/num_comp.c
index c4c364d54edbe25611a192a31f6907a9dc8c5236..559ff36cbf125c0232b358abb41f97278fe23f65 100644 (file)
--- a/o/num_comp.c
+++ b/o/num_comp.c
@@ -42,7 +42,6 @@ number_compare(object x, object y) {
 
   double dx;
   static double dy;
-  object q;
   enum type tx,ty;
 
   tx=type_of(x);
@@ -70,6 +69,7 @@ number_compare(object x, object y) {
       return(number_compare(x, y));
 
     case t_shortfloat:
+      if (FIXSFSP(fix(x))) return number_compare(x,double_to_rational(sf(y)));/*(fix(x)&0x7FFFFFFFFF000000)*/
       {
        volatile float fx=fix(x);
        dx = fx;
@@ -78,6 +78,7 @@ number_compare(object x, object y) {
       goto LONGFLOAT;
 
     case t_longfloat:
+      if (FIXLFSP(fix(x))) return number_compare(x,double_to_rational(lf(y)));
       dx = fix(x);
       dy = lf(y);
       goto LONGFLOAT;
@@ -106,21 +107,10 @@ number_compare(object x, object y) {
       return(number_compare(x, y));
 
     case t_shortfloat:
-
-      if ((float)number_to_double((q=double_to_integer((double)sf(y))))==sf(y))
-       return(number_compare(x,q));
-
-      dx=number_to_double(x);
-      dy=sf(y);
-      goto LONGFLOAT;
+      return number_compare(x,double_to_rational(sf(y)));
 
     case t_longfloat:
-      if (number_to_double((q=double_to_integer(lf(y))))==lf(y))
-       return(number_compare(x,q));
-
-      dx=number_to_double(x);
-      dy=lf(y);
-      goto LONGFLOAT;
+      return number_compare(x,double_to_rational(lf(y)));
 
     case t_complex:
       goto Y_COMPLEX;
@@ -176,6 +166,9 @@ number_compare(object x, object y) {
 
     case t_fixnum:
 
+      if (tx==t_shortfloat ? FIXSFSP(fix(y)) : FIXLFSP(fix(y)))
+       return number_compare(double_to_rational(dx),y);
+
       if (tx==t_shortfloat) {
        volatile float fy=fix(y);
        dy=fy;
@@ -184,11 +177,7 @@ number_compare(object x, object y) {
       goto LONGFLOAT;
 
     case t_bignum:
-
-      if (number_to_double((q=double_to_integer(dx)))==dx)
-       return(number_compare(q,y));
-      dy=number_to_double(y);
-      goto LONGFLOAT;
+      return number_compare(double_to_rational(dx),y);
 
     case t_ratio:
       return(number_compare(double_to_rational(dx),y));
@@ -332,6 +321,9 @@ DEFUN("/=2",object,fSne2,SI
 
 }
 
+DEFCONST("+SFBITS+",sSPsfbitsP,SI,small_fixnum(SFBITS),"Mantissa bits in short-float");
+DEFCONST("+LFBITS+",sSPsfbitsP,SI,small_fixnum(LFBITS),"Mantissa bits in short-float");
+
 
 DEFUN("MAX2",object,fSx2,SI
          ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") {

diff --git a/o/num_sfun.c b/o/num_sfun.c
index 7fd39b248f93894f6784fbc486d0403d4f476d92..f42c0582c5713e7dc335544186e75b6b391beb00 100644 (file)
--- a/o/num_sfun.c
+++ b/o/num_sfun.c
@@ -675,8 +675,8 @@ LFD(Lexp)(void)
 
 DEFUN("EXPT",object,fLexpt,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") {
 
-  check_type_number(&vs_base[0]);
-  check_type_number(&vs_base[1]);
+  check_type_number(&x);
+  check_type_number(&y);
   RETURN1(number_expt(x,y));
 
 }